perm filename UTIL4[AM,DBL]2 blob
sn#168621 filedate 1975-07-17 generic text, type T, neo UTF8
(FILECREATED "17-JUL-75 17:12:13" <LENAT>UTIL4.;9 14598
changes to: INIT-MAC
previous date: "10-JUL-75 17:01:30" <LENAT>UTIL4.;8)
(LISPXPRINT (QUOTE UTIL4COMS)
T T)
[RPAQQ UTIL4COMS
((FNS ACCEPT-B AM-BT CHANGE-B CONDENSEB ED-1F ED-1P ED-1V ED-ALL ED-ALLF ED-ALLP ED-ALLV FORGOT-ANY GLOB
INIT-MAC INIT2 LISTF LISTFILES1 MAPB MAPP MCON MTOP NEW-VERSION NFACET NFUN RESET1 RESET2 RESTORE-EXPR
SAVE SHOWP TRANFUN UPCASE XEQ-CLEAN)
BB GLOBALVARS REPR-FNS SAVECOMS STICKY-B STICKY-P SYS-FORGET-LIST UCASELST VERSION (USERMACROS C COPY)
(P (INIT-MAC))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML MTOP MAPP MAPB]
(DEFINEQ
(ACCEPT-B
[LAMBDA (B SIM)
(CREATEB B)
(TERPRI)
[COND
((FMEMB SIM CONCEPTS))
((PRIN1 "NAME OF SIMILAR BEING... ")
(SETQ SIM (RATOM]
(TERPRI)
(SET B (COPY (GETTOPVAL SIM)))
(SETPROPLIST B (COPY (GETPROPLIST SIM)))
(ERRORSET (LIST (QUOTE EDITV)
B
(LIST (QUOTE RC)
SIM B)))
(ERRORSET (LIST (QUOTE EDITV)
B))
(ERRORSET (LIST (QUOTE EDITP)
B
(LIST (QUOTE RC)
SIM B)))
(ERRORSET (LIST (QUOTE EDITP)
B))
(DEFB B)
(PRIN1 "THE NUMBER OF CONCEPTS IS NOW ")
(PRINT (LENGTH CONCEPTS))
B])
(AM-BT
[LAMBDA (V1)
(MAPDL (FUNCTION (LAMBDA (DX)
(COND
((OR (FMEMB DX (CAR TOP4COMS))
(FMEMB DX (CAR UTIL4COMS))
(FMEMB DX CONCEPTS))
(PRIN1 DX)
(COND
((SETQ V1 (VARIABLES MAPDLPOS))
(TERPRI)
(PRIN1 " ")
(PRINT V1)
(PRIN1 " ")
(PRINT (STKARGS MAPDLPOS)))
((PRIN1 " ---NO ARGS")
(TERPRI])
(CHANGE-B
[LAMBDA (B P CP)
[COND
((OR (FMEMB B FACETS)
(FMEMB B AUX-FACETS))
(SETQ P B)
(PRINT (SETQ B STICKY-B)))
[(GETHASH B HCON)
(OR (FMEMB P FACETS)
(FMEMB P AUX-FACETS)
(PRINT (SETQ P STICKY-P]
(B (TERPRI)
(PRIN1 "***** CANT UNDERSTAND THIS *****")
(HELP))
(T (PRINT (SETQ B STICKY-B))
(PRINT (SETQ P STICKY-P]
(SETQ STICKY-B B)
(SETQ STICKY-P P)
(OR (GETB B P)
(INIT-PART B P))
(ERRORSET (LIST (QUOTE EDITP)
B
(QUOTE F)
P
(QUOTE P)
(QUOTE TTY:)))
(DEFB B)
(TERPRI)
(PRIN1 B)
(PRIN1 COMMA)
(PRINT P])
(CONDENSEB
[LAMBDA (CONFILE)
(SETQ DFNFLG NIL)
(MAPC NEW-PARTS (QUOTE RESTORE-EXPR))
(SETQ VERSION (ADD1 VERSION))
(SETQ CONFILE (PACK (LIST (QUOTE CON)
VERSION)))
(SET (PACK (LIST CONFILE (QUOTE COMS)))
(CONS (CONS (QUOTE FNS)
NEW-PARTS)
NEW-CONCEPTS))
(MAKEFILE CONFILE (QUOTE C))
(NCONC (DREMOVE (QUOTE DUMMY)
NEW-CONCEPTS)
CONCEPTS)
(SETQ NEW-CONCEPTS (LIST (QUOTE DUMMY)))
(SETQ NEW-PARTS NIL)
(SETQ NEW-C-PARTS NIL])
(ED-1F
[LAMBDA (F1)
(AND (ERRORSET (CONS (QUOTE EDITF)
(CONS F1 ECMS)))
(PRIN1 F1)
(PRIN1 " "])
(ED-1P
[LAMBDA (P1)
(AND (CDR P1)
(ERRORSET (CONS (QUOTE EDITP)
(CONS P1 ECMS)))
(PRIN1 P1)
(PRIN1 " "])
(ED-1V
[LAMBDA (V1)
(AND (LITATOM V1)
(OR (NEQ (QUOTE NOBIND)
(GETTOPVAL V1))
(CPRIN1 2 " WARNING: THE VARIABLE " V1 " IS UNBOUND. " CRLF))
(ERRORSET (CONS (QUOTE EDITV)
(CONS V1 ECMS)))
(PRIN1 V1)
(PRIN1 " "])
(ED-ALL
[LAMBDA (EECMS)
(SETQ ECMS EECMS)
(ED-ALLF)
(ED-ALLV)
(ED-ALLP])
(ED-ALLF
[LAMBDA NIL
(MAPC (CDAR TOP4COMS)
(QUOTE ED-1F))
(MAPC CONCEPTS (QUOTE ED-1F))
(MAPC FACETS (QUOTE ED-1F))
(MAPC (CDADR TOP4COMS)
(QUOTE ED-1F))
(MAPC (CDAR CON4COMS)
(QUOTE ED-1F))
(MAPC (CDAR UTIL4COMS)
(QUOTE ED-1F])
(ED-ALLP
[LAMBDA NIL
(MAPC CONCEPTS (QUOTE ED-1P])
(ED-ALLV
[LAMBDA NIL
(MAPC TOP4COMS (QUOTE ED-1V))
(MAPC CON4COMS (QUOTE ED-1V))
(MAPC UTIL4COMS (QUOTE ED-1V))
(MAPC CONCEPTS (QUOTE ED-1V))
(MAPC FACETS (QUOTE ED-1V])
(FORGOT-ANY
[LAMBDA (FF)
(TERPRI)
(PRIN1 "MAYBE YOU FORGOT SOME OF THESE: ")
[MAPATOMS (FUNCTION (LAMBDA (X)
(AND (EXPRP X)
(NOT (MEMB X (CAR TOP4COMS)))
(NOT (MEMB X (CADR TOP4COMS)))
(NOT (MEMB X (CAR UTIL4COMS)))
(NOT (MEMB X CONCEPTS))
(NOT (MEMB X SYS-FORGET-LIST))
(NOT (MEMB X FACETS))
[NOT (MATCH (UNPACK X) WITH (X1←--@[LAMBDA (Z)
(GETHASH Z HCON]
'- X2←--@(LAMBDA (Z)
(MEMB Z FACETS]
(NOT (MEMB X (CAR CON4COMS)))
(NOT (MATCH (UNPACK X) WITH (-- '- 'E '- --)))
(NOT (MATCH (UNPACK X) WITH (-- 'B &@NUMBERP &@NUMBERP &@NUMBERP &@NUMBERP)))
(PRIN1 X)
(PRIN1 (QUOTE % % ))
(SETQ FF T]
(COND
(FF (TERPRI)
(PRINT (QUOTE THINK!!!)))
(T (PRIN1 " NEVER MIND. ")))
(TERPRI])
(GLOB
[LAMBDA (GV)
[COND
((AND GV (NLISTP GV))
(SETQ GV (LIST GV]
(MERGE (SORT GV)
GLOBALVARS)
(SETQ GLOBALVARS (INTERSECTION GLOBALVARS GLOBALVARS))
(PRIN1 " THE NUMBER OF GLOBAL VARAIABLES IS NOW ")
(PRINT (LENGTH GLOBALVARS])
(INIT-MAC
[LAMBDA NIL
(DEFLIST [QUOTE ((FGETB ((B P)
(GETP B P)))
[GETB (X (COND
[(AND (LISTP (CADR X))
(EQ (CAADR X)
(QUOTE QUOTE)))
(COND
((GETP (CADADR X)
(QUOTE UNDO-INIT))
(LIST (GETP (CADADR X)
(QUOTE UNDO-INIT))
(CONS (QUOTE GETP)
X)))
(T (CONS (QUOTE GETP)
X]
(T (LIST (QUOTE APPLY*)
(LIST (QUOTE GETP)
(LIST (QUOTE SETQ)
(QUOTE PMAC)
(CADR X))
(LIST (QUOTE QUOTE)
(QUOTE UNDO-INIT)))
(LIST (QUOTE GETP)
(CAR X)
(QUOTE PMAC]
(ACCESS ((X)
X))
(GETBQ ((B P)
(GETB (QUOTE B)
P)))
(SETBQ ((B P Q)
(PUT (QUOTE B)
(QUOTE P)
Q)))
(UNDO-INIT ((P L)
(APPLY* (GETP P (QUOTE UNDO-INIT))
L)))
[APPLYB (X (COND
((AND (LISTP (CAR X))
(EQ (CAAR X)
(QUOTE QUOTE)))
(CONS (CADAR X)
(CDR X)))
(T (CONS (QUOTE APPLY*)
X]
(CSINT ((X)
(CAAR X)))
(CSOTHERS ((X)
(CDR X)))
(CSBEST ((X)
(CAR X)))
(CINT ((X)
(CAR X)))
(RPLACINT ((X Y)
(RPLACA X Y)))
(PINT ((X)
(CAR X)))
(P-OP ((X)
(CADR X)))
(P-B ((X)
(CADDR X)))
(P-P ((X)
(CADDDR X)))
(COP ((X)
(CADR X)))
(CB ((X)
(CADDR X)))
(CP ((X)
(CADDDR X)))
(CACT ((X)
(CDR X)))
[BPFS ((X)
(CDDR (CADDR (GETD X]
(IPRED ((X)
(CAR X)))
(IDEF ((X)
(CADR X)))
(IVAL ((X)
(CADDR X)))
(IFEATURES ((X)
(CDDR X)))
(IFEA ((X)
(CADR X)))
[TYPE (X (CAR (LAST X]
(ANY-OF (X (CONS (QUOTE OR)
X)))
[ANY1OF (X (PROGN (* RAND-MEMB X)
(CAR X]
(ALL-OF (X (CONS (QUOTE APPEND)
X)))
(Q ((X)
(QUOTE X]
(QUOTE MACRO])
(INIT2
[LAMBDA NIL
(SETQ DFNFLG T)
(SETQ LISPXHISTORY)
(SETQ EDITHISTORY])
(LISTF
[LAMBDA NIL
(TENEX "FTP
SAIL
LOG AM,DBL MER
SEND TOP4≠
TOP4
SEND CON4≠
CON4
SEND UTIL4≠
UTIL4
QUIT
"])
(LISTFILES1
[LAMBDA (X)
[COND
((NULL X)
(TERPRI)
(PRIN1 "NO MORE FILES TO LIST JUST NOW ")
(TERPRI))
((LISTP X)
(SETQ X (CAR X]
(TERPRI)
(SETQ X (UNPACK X))
[AND (EQ (CAR X)
(QUOTE <))
(SETQ X (CDR (FMEMB (QUOTE >)
X]
[SETQ X (PACK (LDIFF X (MEMB (QUOTE ;)
X]
(TERPRI)
(PRIN1 (CONCAT "SHOULD I FTP THE FILE " X " OVER TO SAIL? (Y,N)..."))
(COND
((EQ (RATOM)
(QUOTE Y))
(TENEX (CONCAT "FTP
SAIL
LOG AM,DBL MER
SEND " X "≠
" X "
QUIT
"])
(MAPB
[NLAMBDA (F)
(MAPC CONCEPTS (LIST (QUOTE LAMBDA)
(LIST (QUOTE B))
F])
(MAPP
[NLAMBDA (F)
(MAPC FACETS (LIST (QUOTE LAMBDA)
(LIST (QUOTE P))
F])
(MCON
[LAMBDA NIL
(SETQ CONCEPTS (SORT (COPY CONCEPTS)))
(FORGOT-ANY)
(MAKEFILE (QUOTE CON4)
(QUOTE RC])
(MTOP
[NLAMBDA (X)
[RPLACA TOP4COMS (CONS (QUOTE FNS)
(MERGE X (CDAR TOP4COMS]
(FORGOT-ANY)
(MAKEFILE (QUOTE TOP4)
(QUOTE RC])
(NEW-VERSION
[LAMBDA (NAME VNEW V OLD NEW)
[COND
(V)
((PROG1 (SETQ V VERSION)
(SETQ VERSION (ADD1 VERSION]
(SETQ OLD (PACK (LIST NAME V)))
[SETQ NEW (PACK (LIST NAME (OR VNEW (ADD1 V]
[NLSETQ (SET (PACK (LIST NEW (QUOTE COMS)))
(EVAL (PACK (LIST OLD (QUOTE COMS]
(PRIN1 (CONCAT "OLD: " OLD ", NEW: " NEW ", V:" V ", ECMS: " (QUOTE REPLACEMENT)))
(ED-ALL (LIST (QUOTE RC) OLD NEW])
(NFACET
[LAMBDA (F XEQ-FLAG SUF-FLAG)
[COND
((ATOM F)
(SETQ F (LIST F]
[MAPC F (FUNCTION (LAMBDA (F1)
(PUT F1 (QUOTE ARGS)
(LIST (QUOTE BA1)
(QUOTE BA2)
(QUOTE BA3)
(QUOTE BA4)))
(PUT F1 (QUOTE UNDO-INIT)
(QUOTE ACCESS))
(COND
(XEQ-FLAG (ATTACH F1 XEQ-PARTS)
(ATTACH F1 XS-PARTS)))
(COND
(SUF-FLAG (ATTACH F1 SUF-PARTS)))
(DEFP F1)
(SETQ GTEMP1 (GLUE (QUOTE ANYB)
F1))
(COND
((NOT (GETHASH GTEMP1 HCON))
(CREATEB GTEMP1)
(SET GTEMP1 NIL)
(PUTU GTEMP1 (QUOTE FROM-FILE)
(QUOTE CON4))
(SETB GTEMP1 (QUOTE GENL)
(LIST (QUOTE ANYB-ANYP]
(SETQ FACETS (SORT (UNION F FACETS)))
(PRIN1 " THE NUMBER OF FACETS IS NOW ")
(PRINT (LENGTH FACETS])
(NFUN
[LAMBDA (FUNC FIL)
[COND
((NULL FIL)
(SETQ FIL (QUOTE TOP4]
[SETQ FIL (PACK (LIST FIL (QUOTE COMS]
[RPLACA (EVAL FIL)
(CONS (QUOTE FNS)
(SORT (UNION FUNC (CDAR (EVAL FIL]
(PRIN1 " THERE ARE NOW ")
[PRIN1 (LENGTH (CAR (EVAL FIL]
(PRIN1 " FUNCTIONS ON ")
(PRINT FIL])
(RESET1
[LAMBDA NIL
[MAPB (OR (EQ B (QUOTE LIST-STRUC))
(PROGN (REMPROP B (QUOTE EXS))
(REMPROP B (QUOTE EXS-BDY]
(UNBREAK)
(BREAKDOWN)
(MAPC CONCEPTS (QUOTE BREAKDOWN))
(MAPC (CDAR TOP4COMS)
(QUOTE BREAKDOWN))
(CLOCK 2])
(RESET2
[LAMBDA NIL
(MAPB (OR (EQ B (QUOTE LIST-STRUC))
(PROGN (REMPROP B (QUOTE EXS))
(REMPROP B (QUOTE EXS-BDY])
(RESTORE-EXPR
[LAMBDA (BPNAME)
(UNSAVEDEF BPNAME (QUOTE EXPR])
(SAVE
[LAMBDA NIL
(MAKEFILE (QUOTE SAVE])
(SHOWP
[LAMBDA (P)
(SETQ GTEMP6 NIL)
(MAPB (AND (GETB B P)
(PRINT B)
(PRINT (GETB B P))
(SETQ GTEMP6 (NCONC1 GTEMP6 B))
(TERPRI)))
(PRIN1 " GTEMP6 = ")
GTEMP6])
(TRANFUN
[LAMBDA (F FIL1 FIL2 F1COMS F2COMS)
[COND
((ATOM F)
(SETQ F (LIST F]
[SETQ F1COMS (PACK (LIST FIL1 (QUOTE COMS]
[SETQ F2COMS (PACK (LIST FIL2 (QUOTE COMS]
[COND
((NLISTP (CAR F2COMS))
(PRIN1 " INITIALIZATION IS REQUIRED ")
(TERPRI)
(SET F2COMS (CONS (LIST (QUOTE FNS)
(QUOTE DUMMY))
(COPY (CDR (EVAL F1COMS]
(COND
((NLISTP (CAR F1COMS))
(HELP "FIRST FILE'S COMS IS NULL ")))
(SETQ F (SORT F))
(MERGE (COPY F)
(CDAR (EVAL F2COMS)))
(DREMOVE (QUOTE DUMMY)
(CAR (EVAL F2COMS)))
(MAPC F (FUNCTION (LAMBDA (F1)
(DREMOVE F1 (CAR (EVAL F1COMS])
(UPCASE
[LAMBDA NIL
(SETQ UCASELST (NCONC (SUBSET TOP4COMS (QUOTE ATOM))
(SUBSET CON4COMS (QUOTE ATOM])
(XEQ-CLEAN
[LAMBDA (B B1 B2 B3)
(MATCH (DREVERSE (UNPACK B)) WITH (B2←$
(QUOTE -)
B1←$))
(SETQ B1 (PACK (DREVERSE B1)))
(SETQ B2 (PACK (DREVERSE B2)))
(AND (FMEMB B2 FACETS)
(GETHASH B1 HCON)
NIL) (* NOTNEEDED APPARENTLY.
PERHAPS: in the function CREATEB)
])
)
(RPAQQ BB
(SET-STRUC-DELETE-E-INV STRUCTURE-MEMB STRUCTURE-INSERT RAND-MEMB SET-STRUC-DELETE OSET-STRUC INSTAN-PAT
INSTAN-REC INSTAN-BASE INSTAN-S INSTAN-D INSTAN-I INSTAN-1D INSTAN-1I INSTAN-1S
PICK-CAND XEQ-CAND UPDATE TLOOP GENL FILLIN PXEQ PGET APPLYB-P GETB-P-C RIPPLE-SIMULT
PSUF EXS RAND-THING))
(RPAQQ GLOBALVARS
(ALLOP ARGS AUX-FACETS B-DEF CAND CAND-TAIL CANDS CIRC COMMA CON4COMS CONCEPTS CONSTRUCTIVE-OPS CRLF CS-ACT
CS-B CS-INT CS-OP CS-P CVAL DO-THRESH ECMS EX-THRESH F-COUNTER FACETS FROB FROB1 GATH-PART GEXISTING
GLEN GPGM GPNAME GTEMP GTEMP1 GTEMP10 GTEMP11 GTEMP12 GTEMP13 GTEMP14 GTEMP2 GTEMP3 GTEMP4 GTEMP5
GTEMP6 GTEMP7 GTEMP9 GXTR-PART HCON ILEV INIT-CANDS INIT-DOTHRESH INIT-EXTHRESH INIT-INTHRESH
INIT-ONCE-LIST INIT-PAST INTHRESH JTRASH NEW-C-PARTS NEW-CANDS NEW-CONCEPTS NEW-ILEV NEW-PARTS NEWB
NOSWAP-CONCEPTS OBJX ONCE-LIST OR-PARTS PAST PHIST PKNT PMAC PREC RANC RANDSTATE RANF RANU RB1 RTEM2
STICKY-B STICKY-P STRAT STRATEGY-PARTS SUF-PARTS SUF1 SUF2 SWSUF SYS-FORGET-LIST TOP-ACTS TOP4COMS
TRIV-B TRIVB USERNAMES UTIL4COMS VERBOSITY VERSION XEQ-PARTS XS-PARTS))
(RPAQQ REPR-FNS
(ACCEPT-B APPLYB BPFS CHANGE-B CREATEB DECRB DEFB DEFP DWIMUSERFN GCB GETB GETBQ GETU GLUE GLUEE INCRB
INIT-PART PGET PSUF PUTB PUTU PXEQ SETB SETBQ SWAPB SWGETB SWSETB))
(RPAQQ SAVECOMS (PAST CANDS DO-THRESH INTHRESH EXTHRESH RANDSTATE ILEV PHIST ONCE-LIST PKNT RANU RANC OBJX))
(RPAQQ STICKY-B ACTIVE-INST)
(RPAQQ STICKY-P FILLIN1)
(RPAQQ SYS-FORGET-LIST (DISPLAYTERMP PRETTYCOMPRINT PACK-IN-COMPBLOCK MAKESYS OBIN FGETP OSIN SYSOUT OSFBSZ PUTDQ
/SETPROPLIST SETTOPVAL /SETTOPVAL SETPROPLIST SETFILEPTR))
(RPAQQ UCASELST
(CAND-TAIL COMMA CONSTRUCTIVE-OPS CRLF DO-THRESH DWIMUSERFN EX-THRESH F-COUNTER INIT-CANDS INIT-ONCE-LIST
INIT-PAST INIT-DOTHRESH INIT-EXTHRESH INIT-INTHRESH INTHRESH JTRASH RANDSTATE TOP-ACTS TRIVB
USERNAMES VERBOSITY CONCEPTS FACETS AUX-FACETS SUF-PARTS XEQ-PARTS XS-PARTS))
(RPAQQ VERSION 4)
(ADDTOVAR USERMACROS (COPY (N)
(INSERT (## N)
AFTER N))
(C NIL (MBD * *)))
(ADDTOVAR EDITCOMSA C)
(ADDTOVAR EDITCOMSL COPY)
(INIT-MAC)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA)
(ADDTOVAR NLAML MTOP MAPP MAPB)
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (730 12229 (ACCEPT-B 742 . 1360) (AM-BT 1364 . 1784) (CHANGE-B 1788 . 2444) (CONDENSEB 2448 . 2965)
(ED-1F 2969 . 3084) (ED-1P 3088 . 3215) (ED-1V 3219 . 3467) (ED-ALL 3471 . 3566) (ED-ALLF 3570 . 3847) (ED-ALLP 3851
. 3909) (ED-ALLV 3913 . 4110) (FORGOT-ANY 4114 . 5011) (GLOB 5015 . 5285) (INIT-MAC 5289 . 7431) (INIT2 7435 . 7527)
(LISTF 7531 . 7658) (LISTFILES1 7662 . 8207) (MAPB 8211 . 8304) (MAPP 8308 . 8409) (MCON 8413 . 8543) (MTOP 8547 .
8706) (NEW-VERSION 8710 . 9149) (NFACET 9153 . 9957) (NFUN 9961 . 10290) (RESET1 10294 . 10568) (RESET2 10572 . 10710)
(RESTORE-EXPR 10714 . 10784) (SAVE 10788 . 10837) (SHOWP 10841 . 11060) (TRANFUN 11064 . 11720) (UPCASE 11724 . 11841)
(XEQ-CLEAN 11845 . 12226)))))
STOP